Turnbull China Bikeride/Turnbull China Bikeride - Disc 2.iso/BARNET/COMPILER/SATHER/!Sather/Library/Graphs/sa/ugraph_inc

Text File | 1996-07-13 | 10KB | 340 lines

---------------------------> Sather 1.1 source file <--------------------------
-- Author: Benedict A. Gomes <[e-mail]>
-- COPYRIGHT NOTICE: This code is provided WITHOUT ANY WARRANTY
-- and is subject to the terms of the SATHER LIBRARY GENERAL PUBLIC
-- LICENSE contained in the file: Sather/Doc/License of the
-- Sather distribution. The license is also available from ICSI,
-- 1947 Center St., Suite 600, Berkeley CA 94704, USA.
-------------------------------------------------------------------
partial class UGRAPH_INCL{NTP} < $UGRAPH{NTP} is
   -- Partial class used to define useful routines in  undirected
   -- graphs that are based on a core set of (undefined) routines
   -- The core routines must be defined by a particular implementation
   -- upon inclusion
   private include COMPARE{NTP};

   -- ------------------- Stubs: Must redefine ------------
   stub add_node: NTP;
   stub add_node(n: NTP);
   stub add_node(n: NTP):NTP;
   stub connect(n1,n2: NTP);
   stub delete_node(n: NTP);
   stub disconnect(n1,n2: NTP);
   stub node!: NTP;
   stub adjacent!(once n: NTP): NTP;
   stub copy: SAME;
   stub create: SAME;
   -- Some of the routines need to create a "fresh" graph.

   -- ------------------- Insertion -----------------------
   connect(e: UEDGE{NTP}) is connect(e.first,e.second) end;

   disconnect(e: UEDGE{NTP}) is disconnect(e.first,e.second) end;

   -- ------------------- Access --------------------------
   nodes: SET{NTP} is
      res: SET{NTP};  loop res.insert(node!) end;  return res;
   end;

   edges: SET{UEDGE{NTP}} is
      res: SET{UEDGE{NTP}} := #;  loop res.insert(edge!) end;  return res;
   end;

   adjacent(n: NTP): SET{NTP} is
      res: SET{NTP} := #;  loop res.insert(adjacent!(n)) end;  return res;
   end;

   reachable_from(n: NTP): SET{NTP} is
      -- Returns the set of nodes reachable from "n"
      res: SET{NTP};  loop res.insert(reachable_from!(n)) end; return res;
   end;

   roots: SET{NTP} is
      -- Returns a list of "representative" nodes from which the
      -- whole graph is reachable.
      -- With inout args, also return a mapping from nodes to the
      -- appropriate representative nodes (i.e. seen)
      seen: FSET{NTP};
      roots:SET{NTP};
      loop n ::= node!;
     if ~seen.test(n) then
        roots.insert(n);
        loop  seen := seen.insert(reachable_from!(n));  end;
     end;
      end;
      return roots;
   end;

   node_depths(n: NTP,map:$MAP{NTP,INT}) is
      -- map should be inout, but this will work for now
      -- Do a bfs and return depths of each node
      d ::= 1; loop map[bfs!(n)] := d; d := d + 1; end;
   end;

   -- ------------------- Queries -------------------------
   has_node(n: NTP): BOOL is
      loop if elt_eq(n,node!) then return true end; end;
      return false;
   end;

   has_edge(first,second: NTP): BOOL is
      loop e ::= edge!;
     if elt_eq(e.first,first) and elt_eq(e.second,second) then
        return true;
     end;
      end;
      return false;
   end;

   has_edge(e: UEDGE{NTP}):BOOL is return has_edge(e.first,e.second) end;

   are_connected(n1,n2: NTP): BOOL is
      -- Return true if there exists a path from n1 to n2
      loop n: NTP := dfs!(n1);
     if elt_eq(n,n2) then return true; end;
      end;
      return false;
   end;

   is_empty: BOOL is return(n_nodes = 0) end;

   has(n: NTP): BOOL is return has_node(n) end;

   n_reachable_from(n: NTP): INT is
      i: INT := 0; loop discard ::= reachable_from!(n); i := i + 1;  end;
      return i
   end;

   n_edges: INT is
      i: INT := 0; loop e ::= edge!; i := i + 1; end;
      return i
   end;

   n_nodes: INT is
      i: INT := 0; loop e ::= node!; i := i + 1; end;
      return i
   end;

   size: INT is return n_nodes end;

   n_adjacent(n: NTP): INT is
      i: INT := 0;
      loop adj_n ::= adjacent!(n); i := i + 1; end;
      return i;
   end;

   -- ------------------- Cursor --------------------------
   elt!: NTP is loop yield node! end; end;

   edge!: UEDGE{NTP} is
      seen: FSET{NTP} := #;
      loop n ::= node!;
     seen := seen.insert(n);
     loop
        neigh ::= adjacent!(n);
        if ~seen.test(neigh) then   yield #UEDGE{NTP}(n,adjacent!(n));  end;
        -- Avoid yielding edges twice, from both directions
     end;
      end;
   end;

   filter_edge!(once pred: ROUT{UEDGE{NTP}}:BOOL):UEDGE{NTP} is
      -- Return a set of edge tuples that are true for test "et"
      loop e ::= edge!; if pred.call(e) then yield(e) end; end;
   end;

   filter_node!(once pred: ROUT{NTP}:BOOL): NTP is
      -- Return the set of all nodes in g that satisfy the node test "nt"
      loop n ::= node!; if pred.call(n) then  yield n end end;
   end;

   bfs!(once n: NTP): NTP is
      -- Return all nodes reachable from "n" in bf order
      seen: FSET{NTP} := #;
      q: A_QUEUE{NTP} := #;
      q.enq(n);
      loop until!(q.is_empty);
     current ::= q.remove;
     yield current;
     loop adjacent ::= adjacent!(current);
        if ~seen.test(adjacent) then
           q.enq(adjacent);
           seen:=seen.insert(adjacent);
        end;
     end;
      end;
   end;

   dfs!(once n: NTP): NTP is
      -- Return all nodes reachable from "n" in df order
      stack ::= #FLIST{NTP};  stack := stack.push(n);
      seen  ::= #FSET{NTP};   seen := seen.insert(n);
      loop until!(stack.is_empty);
     cur ::= stack.pop;
     yield cur;        -- Actual visit
     loop neigh ::= adjacent!(cur);
        if ~seen.test(neigh) then
           stack:=stack.push(neigh);
           seen:=seen.insert(neigh);
        end; -- else ( Adjacent has been seen before => backedge.)
     end;
      end; -- Until stack is empty
   end;

   reachable_from!(once n: NTP): NTP is
      -- Returns successive nodes reachable from "n"
      -- using dfs
      loop yield dfs!(n) end;
   end;

   -- ------------------- Comparison ----------------------
   equals(g: $RO_UGRAPH{NTP}): BOOL is
      -- Check that nodes and edges are the same
      -- Very inefficient n^2 version - sort for nlogn version
      if ~has_same_nodes(g) then return false end;
      loop e ::= edge!; if ~g.has_edge(e) then return false end; end;
      loop e ::= g.edge!; if ~has_edge(e) then return false end; end;
      return(true);
   end;

   has_same_nodes(g: $RO_UGRAPH{NTP}): BOOL is
      if n_nodes /= g.n_nodes then return false end;
      loop n ::= g.node!; if ~has_node(n) then return false end; end;
      return true;
   end;

   -- ------------------- Transformation ------------------
   to_union(g: $UGRAPH{NTP}) is
      loop add_node(g.node!) end;
      loop connect(g.edge!) end;
   end;

   to_difference(g: $UGRAPH{NTP}) is
      loop e ::= edge!;
     if g.has_edge(e) then
        disconnect(e);
        f ::= e.first; s ::= e.second;
        if n_adjacent(f) = 0  then delete_node(f) end;
        if n_adjacent(s) = 0 then delete_node(s) end;
     end;
      end;
   end;

   dfs_apply(n: NTP,prewk:ROUT{NTP},postwk:ROUT{UEDGE{NTP}}) is
      -- Perform pre work before visiting a node and
      -- perform postwk on the way back up each edge
      -- Recursive version of dfs (much simpler to code)
      -- Here postwork is applied to *all* edges, including back edges
      if void(postwk) then  dfs_apply(n,prewk);
      else dfs_rec(#FSET{NTP},n,prewk,postwk);
      end;
   end;

   dfs_apply(n: NTP,wk:ROUT{NTP}) is
      -- Apply the pre visit work "wk" to nodes in df order. Non recursive
      stack: FLIST{NTP} := #;
      seen ::= #FSET{NTP};
      seen := seen.insert(n);
      stack := stack.push(n);
      loop until!(stack.is_empty);
     cur ::= stack.pop;
     wk.call(cur);
     loop adjacent ::= adjacent!(cur);
        if ~seen.test(adjacent) then
           stack:=stack.push(adjacent);
           seen:=seen.insert(adjacent);
        end; -- else ( Adjacent has been seen before => backedge.)
     end;
      end; -- Until stack is empty
   end;

   to_transitive_closure is
      -- Convert the graph to it's transitive closure
      -- For a non-destructive version, first make a copy
      loop
     u ::= node!;
     loop v ::= node!;  if are_connected(u,v) then connect(u,v) end; end;
      end;
   end;

   delete_reflexive_edges is
      -- Delete all reflexive edges from the graph
      loop e ::= edge!;
     if elt_eq(e.first,e.second) then disconnect(e) end;
      end;
   end;

   -- ------------------- Conversion ----------------------
   str: STR is
      return(str(bind(node_str(_))));
   end;

   private node_str(n: NTP): STR is
      if void(n) then return("void") end;
      typecase n
      when $STR then  return(n.str); else return("non-printable") end;
   end;

   str(f: ROUT{NTP}:STR): STR is
      -- Print out the graph using the bound routine "f"
      -- for the nodes
      res ::= #FSTR("");
      loop n ::= node!;
     if void(n) then res := res + "void  : ";
     else res := res + f.call(n)+" : "; end;
     loop
        nm: STR := f.call(adjacent!(n));
        res := res + ",".separate!(nm);
     end; -- All parents edges
     res := res+"\n";        -- End of another row of edges
      end; -- All graph nodes
      return(res.str);
   end;

   -- ------------------- Basic Operations ----------------
   union(g: $UGRAPH{NTP}): $UGRAPH{NTP} is
      res: SAME := copy;
      res.to_union(g);
      return res;
   end;

   difference(g:$UGRAPH{NTP}): $UGRAPH{NTP} is
      res: SAME := copy;
      res.to_difference(g);
      return res;
   end;

   induced_subgraph(v: $SET{NTP}): $UGRAPH{NTP} is
      -- Generate a subgraph which is induced by the edges "v".
      res: SAME := #SAME;
      loop n ::= node!;
     res.add_node(n);
     loop a ::= adjacent!(n);
        if v.has(a) then res.connect(n,a) end;
     end;
      end;
      return res;
   end;

   -- ------------------- Implementation ------------------
  private dfs_rec(seen:FSET{NTP},n:NTP,bef:ROUT{NTP},aft:ROUT{UEDGE{NTP}}) is
      -- Recursive depth first search, when both pre and postwork
      -- must be done. Seen holds the list of nodes already seen
      seen := seen.insert(n);
      bef.call(n);
      neigh: $ARR{NTP} := adjacent(n);
      ni: INT; nsz: INT := neigh.size;
      loop until!(ni=nsz);
     child::=neigh[ni];
     bef.call(child);    -- Pre work on node
     if ~seen.test(child) then
        dfs_app_rec(seen,child,bef,aft);
        aft.call(#UEDGE{NTP}(n,child));    -- Post work on edge
     end;
     ni := ni+1;
      end;
   end;

end; -- class UGRAPH_ALG_INCL
-------------------------------------------------------------------